home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / ownrdclb / menumfon.bas < prev    next >
Encoding:
BASIC Source File  |  1998-01-25  |  4.2 KB  |  145 lines
  1. Attribute VB_Name = "mEnumFonts"
  2. Option Explicit
  3.  
  4. ' Win32 SDK recommends the use of EnumFontFamiliesEx rather than the other versions:
  5. Public Const LF_FACESIZE = 32
  6. Public Const LF_FULLFACESIZE = 64
  7. Type ENUMLOGFONTEX
  8.     elfLogFont As LOGFONT
  9.     elfFullName(LF_FULLFACESIZE) As Byte
  10.     elfStyle(LF_FACESIZE) As Byte
  11.     elfScript(LF_FACESIZE) As Byte
  12. End Type
  13. Type NEWTEXTMETRIC
  14.     tmHeight As Long
  15.     tmAscent As Long
  16.     tmDescent As Long
  17.     tmInternalLeading As Long
  18.     tmExternalLeading As Long
  19.     tmAveCharWidth As Long
  20.     tmMaxCharWidth As Long
  21.     tmWeight As Long
  22.     tmOverhang As Long
  23.     tmDigitizedAspectX As Long
  24.     tmDigitizedAspectY As Long
  25.     tmFirstChar As Byte
  26.     tmLastChar As Byte
  27.     tmDefaultChar As Byte
  28.     tmBreakChar As Byte
  29.     tmItalic As Byte
  30.     tmUnderlined As Byte
  31.     tmStruckOut As Byte
  32.     tmPitchAndFamily As Byte
  33.     tmCharSet As Byte
  34.     ' Additional to TEXTMETRIC
  35.     ntmFlags As Long
  36.     ntmSizeEM As Long
  37.     ntmCellHeight As Long
  38.     ntmAveWidth As Long
  39. End Type
  40. Type FONTSIGNATURE
  41.         fsUsb(4) As Long
  42.         fsCsb(2) As Long
  43. End Type
  44. Type TEXTMETRIC
  45.     tmHeight As Long
  46.     tmAscent As Long
  47.     tmDescent As Long
  48.     tmInternalLeading As Long
  49.     tmExternalLeading As Long
  50.     tmAveCharWidth As Long
  51.     tmMaxCharWidth As Long
  52.     tmWeight As Long
  53.     tmOverhang As Long
  54.     tmDigitizedAspectX As Long
  55.     tmDigitizedAspectY As Long
  56.     tmFirstChar As Byte
  57.     tmLastChar As Byte
  58.     tmDefaultChar As Byte
  59.     tmBreakChar As Byte
  60.     tmItalic As Byte
  61.     tmUnderlined As Byte
  62.     tmStruckOut As Byte
  63.     tmPitchAndFamily As Byte
  64.     tmCharSet As Byte
  65. End Type
  66. Type NEWTEXTMETRICEX
  67.     ntmTm As NEWTEXTMETRIC
  68.     ntmFontSig As FONTSIGNATURE
  69. End Type
  70.  
  71. ' Declares:
  72. Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
  73.     lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
  74. Declare Function EnumFontFamiliesEx Lib "gdi32" Alias "EnumFontFamiliesExA" (ByVal hdc As Long, lpLogFont As LOGFONT, ByVal lpEnumFontProc As Long, ByVal lParam As Long, ByVal dw As Long) As Long
  75.  
  76. Private m_lID As Long
  77.  
  78. '/* EnumFonts Masks */
  79. Public Const RASTER_FONTTYPE = 1&
  80. Public Const DEVICE_FONTTYPE = 2&
  81. Public Const TRUETYPE_FONTTYPE = 4&
  82.  
  83. ' Object to add items to:
  84. Private m_ctl As OwnerDrawComboList
  85. Private m_bPrinterFont As Boolean
  86.  
  87. Public Function GetFonts( _
  88.         ByVal lHDC As Long, _
  89.         ctl As OwnerDrawComboList, _
  90.         ByVal bPrinter As Boolean, _
  91.         Optional ByVal sFaceName As String = "" _
  92.     ) As Long
  93. Dim tLF As LOGFONT
  94. Dim i As Integer
  95.     ' No re-entrancy, please:
  96.     If Not (m_ctl Is Nothing) Then Exit Function
  97.     ' Get the fonts:
  98.     m_bPrinterFont = bPrinter
  99.     Set m_ctl = ctl
  100.     m_lID = m_lID + 1
  101.     If Len(sFaceName) > 0 Then
  102.         For i = 1 To Len(sFaceName)
  103.             tLF.lfFaceName(i - 1) = Asc(Mid$(sFaceName, i, 1))
  104.         Next i
  105.     End If
  106.     GetFonts = EnumFontFamiliesEx(lHDC, tLF, AddressOf EnumFontFamExProc, m_lID, 0)
  107.     Set m_ctl = Nothing
  108. End Function
  109.  
  110. Public Function EnumFontFamExProc(ByVal lpelfe As Long, ByVal lpntme As Long, ByVal iFontType As Long, ByVal lParam As Long) As Long
  111. ' The callback function for EnumFontFamiliesEx.
  112.  
  113. ' lpelf points to an ENUMLOGFONTEX structure, lpntm points to either
  114. ' a NEWTEXTMETRICEX (if true type) or a TEXTMETRIC (non-true type)
  115. ' structure.
  116. Dim tLFEx As ENUMLOGFONTEX
  117. Dim sFace As String
  118. Dim lPos As Long
  119. Dim sItem As String
  120. Dim lIconIndex As Long
  121.     
  122.     CopyMemory tLFEx, ByVal lpelfe, LenB(tLFEx) ' Get the ENUMLOGFONTEX info
  123.     sFace = StrConv(tLFEx.elfLogFont.lfFaceName, vbUnicode)
  124.     lPos = InStr(sFace, Chr$(0))
  125.     If (lPos > 0) Then sFace = left$(sFace, (lPos - 1))
  126.     ' Only display printer and true type fonts:
  127.     If Not (m_bPrinterFont) Then
  128.         If (iFontType And TRUETYPE_FONTTYPE) <> TRUETYPE_FONTTYPE Then
  129.             EnumFontFamExProc = 1
  130.             Exit Function
  131.         End If
  132.     End If
  133.     ' Only display a given font once:
  134.     If (m_ctl.FindItemIndex(sFace, True) < 0) Then
  135.         If (m_bPrinterFont) Then
  136.             lIconIndex = 1
  137.         Else
  138.             lIconIndex = 0
  139.         End If
  140.         m_ctl.AddItemAndData sFace, lIconIndex, 2
  141.     End If
  142.     EnumFontFamExProc = 1
  143.     
  144. End Function
  145.